home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HWGRAPH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  6.5 KB  |  231 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2. {**********************************************}
  3. {                                              }
  4. {   HeapSpy - HWGraph Module                   }
  5. {   Copyright (c) 1992  Borland International  }
  6. {                                              }
  7. {**********************************************}
  8.  
  9. unit HWGraph;
  10.  
  11. {$C MOVEABLE DEMANDLOAD DISCARDABLE}
  12.  
  13. interface
  14.  
  15. uses Wintypes, WinProcs, OWindows, Strings, Toolhelp, HWGlobal;
  16.  
  17. type
  18.   PBarGraphWin = ^TBarGraphWin;
  19.   TBarGraphWin = object(TWindow)
  20.     GBrush, RBrush, YBrush, BBrush: hBrush;
  21.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  22.     destructor Done; virtual;
  23.     function GetClassName: PChar; virtual;
  24.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  25.     procedure Paint(PaintDC: hDC; var PaintStruct: TPaintStruct); virtual;
  26.     procedure WMKeyDown(var Msg: TMessage);
  27.       virtual wm_First + wm_KeyDown;
  28.     procedure WMSize(var Msg: TMessage);
  29.       virtual wm_First + wm_Size;
  30.     procedure RebuildGraph(var Msg: TMessage);
  31.       virtual cm_First + cm_Rebuild;
  32.   end;
  33.  
  34. implementation
  35.  
  36. constructor TBarGraphWin.Init;
  37. begin
  38.   inherited Init(AParent, ATitle);
  39.   GBrush := CreateSolidBrush($00008000);
  40.   BBrush := CreateSolidBrush($00800000);
  41.   RBrush := CreateSolidBrush($00000080);
  42.   YBrush := CreateSolidBrush($0000FFFF);
  43. end;
  44.  
  45. destructor TBarGraphWin.Done;
  46. begin
  47.   DeleteObject(RBrush);
  48.   DeleteObject(GBrush);
  49.   DeleteObject(YBrush);
  50.   DeleteObject(BBrush);
  51.   inherited Done;
  52. end;
  53.  
  54. procedure TBarGraphWin.WMKeyDown;
  55. var
  56.   CtrlPress: Boolean;
  57. begin
  58.   CtrlPress := GetKeyState(vk_Control) < 0;
  59.   if Scroller <> nil then
  60.   with Scroller^ do
  61.     case Msg.wParam of
  62.       vk_Up:    ScrollBy(0, -1);
  63.       vk_Down:  ScrollBy(0, 1);
  64.       vk_Left:  ScrollBy(-1 ,0);
  65.       vk_Right: ScrollBy(1, 0);
  66.       vk_Home:
  67.         if not CtrlPress then
  68.           ScrollTo(0, Ypos)
  69.         else
  70.           ScrollTo(0, 0);
  71.       vk_End:
  72.         if not CtrlPress then
  73.           ScrollTo(XRange, YPos)
  74.         else
  75.           ScrollTo(XRange, YRange);
  76.       vk_Prior: ScrollBy(0, -YPage);
  77.       vk_Next:  ScrollBy(0, YPage);
  78.     end;
  79. end;
  80.  
  81. procedure TBarGraphWin.WMSize;
  82. begin
  83.   inherited WMSize(Msg);
  84. end;
  85.  
  86. type
  87.   THeapSizes = record
  88.     hsCode: LongInt;
  89.     hsCodeLocked: LongInt;
  90.     hsData: LongInt;
  91.     hsDataLocked: LongInt;
  92.     hsOther: LongInt;
  93.     hsOtherLocked: LongInt;
  94.     hsFree: LongInt;
  95.     hsTotal: LongInt;
  96.   end;
  97.  
  98. procedure ComputeHeapSizes(var HS :THeapSizes);
  99. var
  100.   G: TGlobalEntry;
  101.   TotalHeap: LongInt;
  102.   MM: TMemManInfo;
  103. begin
  104.   FillChar(HS,Sizeof(HS),0);
  105.   TotalHeap := 0;
  106.   G.dwSize := Sizeof(TGlobalEntry);
  107.   GlobalFirst(@G,GLOBAL_ALL);
  108.   repeat
  109.     Inc(TotalHeap,G.dwBlockSize);
  110.     with G do
  111.       case wType of
  112.         gt_Code:
  113.           if wcPageLock = 0 then
  114.             Inc(HS.hsCode, dwBlockSize)
  115.           else
  116.             Inc(HS.hsCodeLocked, dwBlockSize);
  117.         gt_Data,gt_DGroup,gt_Unknown:
  118.            if wcPageLock = 0 then
  119.              Inc(HS.hsData, dwBlockSize)
  120.            else
  121.              Inc(HS.hsDataLocked, dwBlockSize);
  122.         gt_Free:
  123.            Inc(HS.hsFree, dwBlockSize);
  124.       else
  125.         if wcPageLock = 0 then
  126.           Inc(HS.hsOther, dwBlockSize)
  127.         else
  128.           Inc(HS.hsOtherLocked, dwBlockSize);
  129.       end;
  130.   until not GlobalNext(@G, global_All);
  131.   with HS do
  132.   begin
  133.     hsTotal := TotalHeap div 1024;
  134.     hsCode := hsCode div 1024;
  135.     hsCodeLocked := hsCodeLocked div 1024;
  136.     hsData := hsData div 1024;
  137.     hsDataLocked := hsDataLocked div 1024;
  138.     hsOther :=  hsOther div 1024;
  139.     hsOtherLocked := hsOtherLocked div 1024;
  140.     hsFree := hsFree div 1024;
  141.   end;
  142. end;
  143.  
  144. procedure TBarGraphWin.Paint(PaintDC: HDC; var PaintStruct: TPaintStruct);
  145. var
  146.   Rect: TRect;
  147.   HeapSizes: THeapSizes;
  148.   OldBrush: hBrush;
  149.   OldPen,DashPen  : hPen;
  150.   OldAlign: Word;
  151.   YInc,YPos,i: Integer;
  152.   Temp: array[0..11] of char;
  153. const
  154.   yOfs: Integer = 2000;
  155. begin
  156.   ComputeHeapSizes(HeapSizes);
  157.   GetClientRect(hWindow, Rect);
  158.   SetMapMode(PaintDC, mm_Anisotropic);
  159.   YOfs := HeapSizes.hsTotal div 10;
  160.   SetWindowExt(PaintDC, 19000, (yOfs * 2) + HeapSizes.hsTotal);
  161.   SetViewPortExt(PaintDC, Rect.Right, -Rect.Bottom);
  162.   SetViewPortOrg(PaintDC, 0, Rect.Bottom);
  163.   SetBKMode(PaintDC, Transparent);
  164.   with HEapSizes do
  165.   begin
  166.  
  167.     {- Draw Bounding Rectangle}
  168.     OldBrush := SelectObject(PaintDC, GetStockObject(ltGray_Brush));
  169.     Rectangle(PaintDC, 1000, Yofs, 18000, yOfs + HeapSizes.hsTotal);
  170.  
  171.     {- Draw % lines }
  172.     YInc := HeapSizes.hsTotal div 10;
  173.     DashPen := CreatePen(ps_Dot, 1, 0);
  174.     OldPen := SelectObject(PaintDC, DashPen);
  175.     YPos := YOfs + YInc;
  176.     for i := 1 to 9 do
  177.     begin
  178.       MoveTo(PaintDC,1000,YPos);
  179.       LineTo(PaintDC,18000,YPos);
  180.       Inc(YPos,YInc);
  181.     end;
  182.     SelectObject(PaintDC,OldPen);
  183.     DeleteObject(DashPen);
  184.  
  185.     {- Draw bars of graph }
  186.     SelectObject(PaintDc, BBRush);
  187.     Rectangle(PaintDC, 1000, yOfs, 3000, yOfs + hsCode);
  188.     Rectangle(PaintDC, 3000, yOfs, 5000, yOfs + hsCodeLocked);
  189.     SelectObject(PaintDC, RBrush);
  190.     Rectangle(PaintDC, 6000, yOfs, 8000, yOfs + hsData);
  191.     Rectangle(PaintDC, 8000, yOfs, 10000, yOfs + hsDataLocked);
  192.     SelectObject(PaintDC, GBrush);
  193.     Rectangle(PaintDC, 11000, yOfs, 13000, yOfs + hsOther);
  194.     Rectangle(PaintDC, 13000, yOfs, 15000, yOfs + hsOtherLocked);
  195.     SelectObject(PaintDC, YBrush);
  196.     Rectangle(PaintDC, 16000, yOfs, 18000, yOfs + hsFree);
  197.     SelectObject(PaintDC, OldBrush);
  198.     TextOut(PaintDC, 1000, yOfs, 'Code', 4);
  199.     TExtOut(PaintDC, 6000, yOfs, 'Data', 4);
  200.     TextOut(PaintDC, 11000, yOfs, 'Other', 5);
  201.     TextOut(PaintDC, 16000, yOfs, 'Free', 4);
  202.     SetTextAlign(PaintDC, ta_Bottom);
  203.     Str(hsCode, Temp);
  204.     TextOut(PaintDC, 1000, yOfs + hsCode, Temp, StrLen(Temp));
  205.     Str(hsData, Temp);
  206.     TExtOut(PaintDC, 6000, yOfs + hsData, Temp, StrLen(Temp));
  207.     Str(hsOther, Temp);
  208.     TextOut(PaintDC, 11000, yOfs + hsOther, Temp, StrLen(Temp));
  209.     Str(hsFree, Temp);
  210.     TextOut(PaintDC, 16000, yOfs + hsFree, Temp, StrLen(Temp));
  211.   end;
  212. end;
  213.  
  214. procedure TBarGraphWin.RebuildGraph;
  215. begin
  216.   InvalidateRect(hWindow,nil,false);
  217. end;
  218.  
  219. procedure TBarGraphWin.GetWindowClass(var WndClass: TWndClass);
  220. begin
  221.   inherited GetWindowClass(WndClass);
  222.   WndClass.hIcon := LoadIcon(hInstance, PChar(ico_Graph));
  223. end;
  224.  
  225. function TBarGraphWin.GetClassName: PChar;
  226. begin
  227.   GetClassName := 'HWBarGraph';
  228. end;
  229.  
  230. end.
  231.